perm filename SCANX.F4[M11,LCS] blob
sn#400677 filedate 1978-12-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C ***** SCANNER *************************
C00030 ENDMK
C⊗;
C ***** SCANNER *************************
C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR,PARAM,ALL 7/78
SUBROUTINE SCANR
COMMON /PCIP/ PCH(27,102),IPT(27,101)
COMMON/P/P(1) /PL/PL(1)
DIMENSION IP(1)
COMMON J,L,CNT(27),BT,MK,DF,DUR(27)
1/E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
1 ,(IEN,ISCA(4)),(IP,PL),(I0,IDAT),(I9,IDAT(10)),(IPP,ISCA(2))
C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
KPAR=0
999 IDECI=-1
M=0
2799 N=INP(ML)
IF(N.NE.IQT)GO TO 899
JA=-1
ML=ML+1
ISUB=8
JJ=JJ+1
VX(JJ)=ML
C POINTS TO FIRST LIT. CHAR.
DO 1177 K=ML,144
IF(INP(K).NE.IQT)GO TO 1177
ML=K+1
2177 N=INP(ML)
GO TO 899
1177 CONTINUE
C SKIPS 'LIT' ITEMS IN RAN. SELECTION
899 ML=ML+1
IF(N.EQ.':')GO TO 751
IF(N.EQ.ISEMI)GO TO 751
IF(N.NE.IBLA)GO TO 510
4702 IF(ISKP)202,2799,2799
510 IF(N.NE.IPP)GO TO 4511
C CATCH PARAM NUMS. GO UP AND CHANGE TO MAGIC NUMBER.
K=INP(ML)
IF(K.LT.I0.OR.K.GT.I9)GO TO 4511
KPAR=-1
JA=0
C JA=0 SO SCANR WILL FIND NOTES OR NUMS LATER.
GO TO 2177
4511 IF(JA)GO TO 70
CCCC510 IF(JA)GO TO 70
C********** MAY 22,71
DO 77 K=1,12
IF(N.NE.ISCA(K))GO TO 77
IF(K.EQ.2)GO TO 1511
CX IF(K.NE.2)GO TO 1510
C P=PROXIMITY MODE -- OR A PARAM NUM.
CX3511 N=INP(ML)
CX IF(N.GE.I0.AND.N.LE.I9)GO TO 2511
CCCC IF(N.LT.I0.OR.N.GT.I9)GO TO 1511
CX IF(JA.GE.0)CALL ERR(6)
C ERROR IF NO NUM AFTER P WHEN ONLY NUMS ARE EXPECTED.
CX GO TO 1511
CX2511 KPAR=-1
C FINDS PARAMETER NUMBER (E.G. P13) USED AS A SIMPLE NUMBER. (KPAR IS FLAG)
CX GO TO 2177
1510 IF(K.NE.4)GO TO 511
C K=2=P, =4=O ('ORDINARY')
1511 NSWCH=K-4
GO TO 2177
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
C ************ MAY 22,71
511 NNUM=K
JJ=JJ+1
NFLG=-1
N=INP(ML)
IF(N.NE.IF)GO TO 410
NNUM=NNUM-1
GO TO 610
410 IF(N.NE.ISS)GO TO 3410
NNUM=NNUM+1
610 ML=ML+1
N=INP(ML)
3410 IF(N.EQ.IEN)GO TO 3411
IF(N.NE.'I')GO TO 371
C 'END' OR 'FINE' WILL END INST.
C******** MAY 20,71
3411 VX(JJ)=-10000.
CIRC3411 VX(JJ)=10000.
IF(DUR(LK))DUR(LK)=10000.
IAMP=-1
RETURN
371 IF(N.EQ.ISEMI)GO TO 5410
IF(N.EQ.IBLA)GO TO 5410
DO 177 KN=1,10
IF(N.NE.IDAT(KN))GO TO 177
CC IF(KN.GE.9)CALL ERR(4)
C FOUND OCTAVE NUM. >8 -- TOO HIGH! ***** OK TO 9 NOW 7/78
JSCA=KN-1
CC JSCA=KN-2
ML=ML+1
GO TO 2410
177 CONTINUE
GO TO 6410
5410 KN=-1
6410 IF(NSWCH.EQ.0)GO TO 2410
IF(KN)GO TO 7410
CC IF(N.EQ.'+')NOLD=NOLD+6
CC IF(N.EQ.'-')NOLD=NOLD-6
C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
7410 IF(NOLD-NNUM.LE.5)GO TO 7411
IF(JSCA.LT.7)JSCA=JSCA+1
7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
IF(JSCA.GT.0)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
2410 VX(JJ)=JSCA*12+NNUM
CCC2410 VX(JJ)=JSCA*12+NNUM
NOLD=NNUM
C ********** MAY 22,71
4410 NNUM=-2
IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
GO TO 310
C *********MAY 22,71
77 CONTINUE
70 IF(N.NE.'-')GO TO 71
XMINUS=-1.
GO TO 2799
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
C****** MAY 19,71
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
71 IF(N.EQ.IXX)GO TO 210
IF(N.EQ.'*')GO TO 210
IF(N.EQ.'R')GO TO 73
CXX IF(N.EQ.IPP)GO TO 3511
C CATCH PARAM NUMS. GO UP AND CHANGE TO MAGIC NUMBER.
1410 DO 78 K=1,11
IF(N.NE.IDAT(K))GO TO 78
ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDECI=M
GO TO 75
79 M=M+1
IP(M)=K-1
GO TO 75
78 CONTINUE
IF(N.NE.IE)GO TO 8811
IF(INP(ML).NE.IEN)GO TO 781
GO TO 7811
8811 IF(N.NE.IF)GO TO 781
IF(INP(ML).NE.'I')GO TO 781
C 'EN(D)' OR 'FI(NE)' WILL END INST.
7811 JJ=1
GO TO 3411
781 IF(N.EQ.'/')N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
75 KN=INP(ML)
CXX IF(KN.NE.'R')GO TO 275
CXX IF(INP(ML+1).NE.IE)GO TO 175
C NOW FOUND A 'REP'
CXX ML=ML+2
CXX GO TO 202
275 IF(KN.NE.IXX)GO TO 175
CC IF(INP(ML+1).NE.'(')GO TO 202
C "X(" STARTS A 'MOTIF' BUT "X (" WON'T WORK!!!!
IF(M.NE.0)GO TO 202
175 IF(KN.EQ.'*')GO TO 202
C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
CC75 IF(INP(ML).NE.IXX)GO TO 752
CC ML=ML-1
CC GO TO 202
C FOR 'X' AND '*' WITHOUT SPACES.
IF(N.EQ.ISEMI)GO TO 751
IF(KN.EQ.IQT)GO TO 751
C SO YOU CAN TYPE .5"F7" ETC. (NO SPACE)
IF(KN.NE.1)GO TO 2799
C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
751 IF(ISKP.EQ.0)RETURN
202 IF(IDECI.NE.-1)GO TO 302
IDECI=0
GO TO 402
302 IDECI=M-IDECI
402 KN=0
IEXP=M-1
IF(M.LT.1)M=1
DO 171 K=1,M
KV=10**IEXP
IF(IEXP.EQ.0)KV=1
KN=KN+IP(K)*KV
171 IEXP=IEXP-1
A=10**IDECI
IF(IDECI.EQ.0)A=1.
JJ=JJ+1
A=KN/A*XMINUS
CC VX(JJ)=KN/A*XMINUS
IF(KPAR.EQ.0)GO TO 172
A=-9999.-A/100.
KPAR=0
C CHANGES P13 TO -9999.13, FOR EXAMPLE.
172 VX(JJ)=A
IF(ISUB.EQ.1)RETURN
IF(CODE.NE.-22.)XMINUS=1.
C ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ+1)=VX(JJ)*2.
JJ=JJ+1
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
C******** MAY 19,71
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
IF(INP(ML).EQ.IE)GO TO 206
C NEXT IS FOR A REST ('R')
VX(JJ)=199.
CCC VX(JJ)=85.
C 7/75 GO TO 4410
731 N=INP(ML)
IF(N.EQ.'/')RETURN
IF(N.EQ.ISEMI)RETURN
IF(N.NE.IBLA)GO TO 899
ML=ML+1
GO TO 731
END
SUBROUTINE BGSORT(BW)
C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
C ALLOWS 100 BG TIMES.
COMMON /Q/ BNW(200),NWZ
C****NEEDS TRAP FOR EXCEEDING 200 LIMIT ⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
DO 5308 K=1,NWZ
X=BNW(K)-.0001
Y=X+.0002
C ROUND-OFF NONSENSE
IF(BW.LE.X)GO TO 5308
IF(BW.LT.Y)RETURN
5308 CONTINUE
NWZ=NWZ+1
BNW(NWZ)=BW
RETURN
END
SUBROUTINE FMT(JFM,INP,MLX)
DIMENSION JFM(3),INP(1)
DO 1 MLX=2,72
J=INP(MLX)
IF(J.EQ.' ')J=' '
C ABOVE FINDS A TAB, CHANGES IT TO BLANK SPACE
IF(J.EQ.' ')GO TO 2
IF(J.EQ.',')GO TO 2
IF(J.EQ.';')GO TO 2
1 CONTINUE
C*** TEMPORARY CHANGE ***** IF(J.EQ.':')GO TO 3
C SPACE=COMMA=SPACE, ALSO STOPS ON ";"
3 CALL ERR(1)
C ERROR IF COLON IS FOUND OR THERE IS NO END MARK
2 MLX=MLX+1
IF(MLX.GT.7)MLX=7
JFM(2)='0'+(MLX-2)*536870912
C FINDS NUMBER FOR 'A' FORMAT
END
SUBROUTINE RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE AND ADDS .999
DIMENSION VX(1)
CC X=VX(K)
CC Y=VX(K+1)
CC IF(X.GT.Y)VX(K)=X+.999
CC IF(Y.GE.X)VX(K+1)=Y+.999
J=K+1
IF(VX(K).GT.VX(K+1))J=J-1
IF(VX(J).GT.-9999.)VX(J)=VX(J)+.999
C AVOID TAMPERING WITH PARAM NUMS.
END
SUBROUTINE SQYY(YY,X,Y,Z)
YY=2.*Z/(X+Y)
IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
RETURN
END
SUBROUTINE COLTTY(JNP,JT)
COMMON /TYP/SOS,JOUT,LN,ITYP,JED /FRMT/J(2)
DIMENSION JNP(1)
DATA J(2)/'80A1)'/
DO 1 K=72,1,-1
JJ=JNP(K)
1 IF(JJ.NE.' '.AND.JJ.NE.' ')GO TO 2
C SECOND SPACE IS A TAB.
K=1
2 IF(JT.EQ.21)GO TO 3
J(1)=' (1X'
IF(LN.EQ.0)GO TO 5
J(1)='(I6,X'
WRITE(JT,J)LN,(JNP(L),L=1,K)
RETURN
3 J(1)=' ('
5 WRITE(JT,J)(JNP(L),L=1,K)
END
FUNCTION READER(JNP)
DIMENSION JNP(80)
COMMON /TYP/SOS,JOUT,LN,ITYP,JED
1 /FRMT/J(2) /IFI/IFI
J(1)=' ('
READER=0
IF(ITYP)GO TO 1
2203 FORMAT(' TYPE A LINE'/)
6 TYPE 2203
ACCEPT J,JNP
IF(JED)CALL COLTTY(JNP,21)
GO TO 8
CC1 IF(IFI)GO TO 5
1 IF(LN.NE.0)GO TO 5
READ(23,J,END=3)JNP
GO TO 7
3 READER=-1
GO TO 8
5 J(1)=' (I,'
READ(23,J,END=3)LN,JNP
7 IF(SOS)CALL COLTTY(JNP,JOUT)
8 IF(JNP(1).EQ.' ')JNP(1)=' '
C CHANGES TAB TO SPACE ABOVE.
END
SUBROUTINE QUAD
C DUMMY -- FOR NOW. 7/74
END
FUNCTION RMOVX(W,Y,Z)
IF(W.EQ.0)W=.01
IF(Y.EQ.0)Y=.01
RMOVX=Y*((W/Y)**Z)
END
SUBROUTINE CLEAN(LEND)
COMMON /E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,
1 IXX,ISEMI,IQT
1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,J,KN,O,ML,CODE,IBLA
DATA LA/"605004020100/,LZ/"751004020100/,MAG/"200000000000/
CC ↑↑↑↑DATA LA/'a'/, LZ/'z'/, MAG/'a'-'A'/
C CLEAR THE END OF ARRAY
M=72
LEND=-1
K=0
DO 10 LL=73,80
IF(INP(LL).EQ.' ')GO TO 10
C THIS 'ERR' IS JUST A WARNING
CALL ERR(11)
GO TO 1
10 CONTINUE
1 K=K+1
NN=INP(K)
IF(NN.EQ.';')GO TO 2
IF(NN.EQ.'/')GO TO 2
IF(NN.EQ.'<')GO TO 3
CCC IF(NN.NE.'<')GO TO 5
CCC INP(K)=' '
CCC GO TO 3
C USE < FOR COMMENT-- AS IN MUS10
5 IF(NN.EQ.','.OR.NN.EQ.' ')INP(K)=' '
CHANGE ALL COMMAS AND TABS TO BLANKS(IT LOOKS LIKE A BLANK ABOVE, BUT ISN'T)
C**** FOR CHORD FEATURE IF(NN.EQ.':')CALL ERR(1)
8 IF(NN.NE.'"')GO TO 4
7 K=K+1
IF(INP(K).EQ.'"')GO TO 4
IF(K.LT.M)GO TO 7
CALL ERR(5)
2 LEND=K
4 IF(K.LT.M)GO TO 1
3 IF(LEND.EQ.0)GO TO 9
DO 11 K=1,LEND
NN=INP(K)
11 IF(NN.GE.LA.AND.NN.LE.LZ)INP(K)=NN-MAG
C ABOVE CHANGES LOWER CASE LETTERS TO UPPER.
IF(LEND.GT.0)RETURN
CCCCCC RETURN
9 IF(M.EQ.145)CALL ERR(2)
C LINES STARTING WITH P OR C CAN POSSIBLY HAVE NO SEMICOLON IN THEM.
CC IF(INP(1).NE.'P'.AND.INP(1).NE.'C')CALL ERR(2)
6 CALL READER(INP(74))
C GO READ ANOTHER LINE.
M=INP(74)
IF(M.GE.'A'.AND.M.LE.'Z')CALL ERR(2)
C ONE EXTRA SPACE (M=145, NOT 144) FOR THE CRLF.
M=145
K=72
INP(73)=' '
GO TO 1
END
SUBROUTINE ERR(K)
COMMON /ERRFLG/ERRFLG /TYP/SOS,JOUT /E/IQ(27),ISKP,XMINUS,N,
1 IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT,INP(74)
IF(SOS.EQ.0)TYPE 999,INP
GO TO(1,2,3,4,5,6,7,8,9,10,11,12,13)K
TYPE 199,K
199 FORMAT(' ***** ERROR!! SOMEWHERE UP TO HERE. ***-FATAL-***'/)
GO TO 200
1 TYPE 101
GO TO 200
101 FORMAT(' ***** COLON WANTED HERE? ***-FATAL-***'/)
CCC11 FORMAT(/' ILLEGAL COLON')
2 TYPE 102
GO TO 200
102 FORMAT(' ***** NO END MARK OR SEMICOLON ***-FATAL-***'/)
3 TYPE 103
GO TO 200
103 FORMAT(' ***** MORE THAN 2 PARENS OPEN ***-FATAL-***'/)
4 TYPE 104
GO TO 200
104 FORMAT(' ***** SOME NUMBER OUT OF BOUNDS ***-FATAL-***'/)
5 TYPE 105
GO TO 200
105 FORMAT(' ***** OPEN QUOTES ***-FATAL-***'/)
6 TYPE 106
GO TO 200
106 FORMAT(' ***** PARAM NUMBER ERROR: >99 ***-FATAL-***'/)
7 TYPE 107
GO TO 200
107 FORMAT(' ***** TOO MANY INSTS ***-FATAL-***'/)
8 TYPE 108
GO TO 200
108 FORMAT(' ***** MOTIVE ERROR ***-FATAL-***'/)
9 TYPE 109
GO TO 200
109 FORMAT(' ***** "MOVE" ERROR ***-FATAL-***'/)
10 TYPE 110
GO TO 200
110 FORMAT(' ***** MISSING "*" ***-FATAL-***'/)
11 TYPE 111
RETURN
111 FORMAT(' **** WARNING: CHARACTERS FOUND BEYOND COLUMN 72'/)
12 TYPE 112
GO TO 200
999 FORMAT(1X74A1)
112 FORMAT(
1' ***** WRONG NUM. OF ELEMENTS IN RAN. SELECTION. ***-FATAL-***'/)
13 TYPE 113
113 FORMAT(' ***** WRONG FORMAT FOR P2. ***-FATAL-***'/)
200 ERRFLG=-1
C THIS WILL CAUSE EXIT BEFORE 'RUNIT'.
END
SUBROUTINE ACCEL
COMMON /PCIP/ PCH(27,102),IPT(27,101)
COMMON/P/P(1) /PL/PL(1)
COMMON/VV/LIMIT,V(1)/A/ROFF(27),NP(27),
1 RDEV(27),XT(27),OTH(20,16),P1(27),JFM(4),IFM(80)
1 ,FINM(6),TINST(5),ENFI(5),INVIS(27)
COMMON J,L,CNT(27),BT,MK,DF,DUR(27)
1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
1 ,INP(145),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
COMMON/B/MOT,PR,T5,NINS,I,RA,KZY,NWX,INONLY,MX,
1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
1 ZZ,CHN,YY
1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
C /C/=26
IF(T5.EQ.1)GO TO 4020
XA=RA
7020 RA=V(IA+K)
IF(RA.EQ.-10000.)RETURN
4020 RD=1
IF(RA.LT.0)RD=-1.
RA=RA*RD
IF(KA.EQ.0)RA=RA-RC
W=RA
RB=W
IF(W.LE.Z-.0001)GO TO 2020
C .0001 FOR ROUND-OFF ERRORS!!!!!!!
IF(Z.NE.0)GO TO 3020
RA=RA/Y
RB=-1.
RC=0
GO TO 8020
3020 W=Z
RC=W+RC
GO TO 24
2020 RC=0
24 IF(X.NE.Y)GO TO 424
RA=W/X
GO TO 8020
C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
C BG TIME OF NOTE. CHN=TBG.
424 RAX=XT(J)
RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
XT(J)=RAX+YY*RA
8020 IF(KA.EQ.0)RA=RA+XA
KA=1
CXX IF(RC.NE.0)GO TO 1011
CCXX IF(T5.EQ.1)RETURN
IF(T5.NE.1)GO TO 1012
IF(RC.NE.0)GO TO 2011
RETURN
C T5=1 IN 'RUNIT'
1012 V(IA+K)=RA*RD
IF(K.EQ.IZ)RETURN
C*********** JUNE 1,71
1011 IF(T5.EQ.1)GO TO 2011
K=K+1
IF(ZZ.NE.0)Z=Z-W
IF(Z.GT.0)GO TO 7020
IF(RB.EQ.-1.)GO TO 7020
IC=IC+1
IF(RB.EQ.W)RETURN
KA=0
K=K-1
RETURN
2011 XA=RA
IF(K.GT.1)GO TO 9020
K=I-6
ZPAR=-9900.-CHN-ZZ
DO 3011 KL=8,I
IF(V(K).NE.ZPAR)GO TO 3011
IF(V(K+1).EQ.990000.)GO TO 9020
3011 K=K-1
9020 W=ZZ
IF(V(K+3))K=K+3
C ABOVE IS FOR TYPED IN TEMPO CHANGES
KA=K+3
ZZ=V(KA)
C DUR OF NEXT TEMPI
X=V(KA+1)
Y=V(KA+2)
213 KA=0
Z=ZZ
CALL SQYY(YY,X,Y,Z)
CHN=CHN+W
XT(J)=X
IF(KA.EQ.1)Z=0
RA=PR
KA=0
K=K+3
GO TO 4020
END
SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
COMMON/VV/LIMIT, V(2000)
C TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
C KODES: -22=RHY -33=NOTES -44=NUMS -46=RLIST -36=RNOTES
C -11=SUBN -12=SUBR -55=MOVE NUMS -56=MOVE NOTES
C -66=DUPL -88=LIT -57=MOVE RANGE NUMS -58=MOVE RNG NOTES
DO 1 K=1,2000
N=V(K)
IF(N.LT.10000)GO TO 1
IF(N/10000.NE.INUM)GO TO 1
IF(MOD(N,10000).NE.IPAR)GO TO 1
ISTRT=K+4
KODE=V(K+2)
ICNT=V(K+3)
IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
RETURN
C FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
1 CONTINUE
END
CC SUBROUTINE NMCHG
CC DIMENSION RNAME(5),JNM(5)
CC COMMON /INS/ INST(27),BG(60)
CC COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
CC COMMON/VV/LIMIT, V(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,IL
CC 1,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2,T1,RD,VIJ2
CC EQUIVALENCE (RNAME,JNM)
CC DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC DATA MM/"774000000000/
CC P(IPAR)=0
C REPLACE NAME BY A ZERO FOR THIS PARAM.
CC PL(IPAR)=1.
CC J=PM-1
C PM POINTS TO 1ST WORD OF LIT. STRING., PAR= LAST
CC N=V(J)
C THE WORD COUNT
CC DO 15 K=1,5
CC J=J+1
CC X=V(J)
CC IF(K.GT.N)X=' '
CC15 RNAME(K)=X
C N=WDCNT OF INST NAME
CC NN=0
CC DO 10 K=5,1,-1
CC NN=NN .OR. (JNM(K) .AND. MM)
CC IF (K-1) 20,20,17
CC17 IF (NN.GE.0)GO TO 13
CC NN = (( NN .AND. LL)/KK) .OR. JJ
CC GO TO 10
CC13 NN = NN / KK
CC10 CONTINUE
CC20 INST(INUM)=NN
CC END
SUBROUTINE SHORT(KNP,K)
C DON'T TYPE TRAILING BLANKS
DIMENSION KNP(1)
DO 1 K=15,1,-1
1 IF(KNP(K).NE.' ')RETURN
K=1
END
C***** THIS IS NOW A 'FAIL' ROUTINE IN SPRINT.FAI
CC FUNCTION PARAM(X,K)
CC COMMON J,L /P/P(1) /PL/PL(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,
CC 1 T2,T4,BY,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2
CC K=0
C IF K IS NOT ZERO UPON RETURN, THEN WE'VE FOUND INFO IN OTHER PARAM.
CC PARAM=X
CC IF(X.GT.-9999.0)RETURN
CC IF(X.EQ.-10000.0)RETURN
CC K=-(X+9999.0)*100.+.1
CC PARAM=P(K)
C GET DATA FROM PARAM K
CC PM=PL(K)
CC IF(L.NE.2)RETURN
C L=CALLING PARAM NUM., K=PARAM REFERRED TO.
CC IF(K.EQ.2)PARAM=PX2
C MUST USE 'UNPROCESSED' FORM OF P2 (I.E. NO 'TEMPO' CHANGES)
CC END
C***** MICROTONES ********
SUBROUTINE MICRO
COMMON INUM,IPAR /P/P(1) /PL/PL(1)
C CALL SUBROUTINE FROM ANY PARAMETER WHERE THE CALLING PARAMETER
C AND THE IMMEDITELY PRECEDING PARAMETER ARE UNUSED BY YOUR INSTR.
C P3 CAN BE NOTES OR NUMBS.
X=P(3)
IF(PL(3).EQ.1)GO TO 1
CC X=IFIX(X)
C FOR RAND NOTES TO LOCK ON NOTE NUMBERS.
CC X=30.8677*2**(X/12)
X=15.43385*2**(X/12)
C X=FREQ. IN HZ. BASED ON NT # IN P3. NUM. ABOVE IS B, IE. LOWEST B -1 OCT.
PL(3)=1.
C THIS CAUSES FREQ. NUM TO PRINT INSTEAD OF LITERAL CHARACTERS.
1 Y=IFIX(P(IPAR-1))
Z=IFIX(P(IPAR))
C FIX NEEDED BECAUSE OF POSSIBLE NON-INTEGERS HERE.
P(3)=X*2**(Y/Z)
C IPAR (Z) IS THE CALLING PARAMETER. IPAR-1 (Y) THE PREVIOUS PARAM.
C X HAS BASE FREQ.
C THE NUMBER IN P(IPAR)=# OF DIVISIONS OF THE OCTAVE.
C THE NUMBER IN P(IPAR-1)=CHROMATIC STEP IN THAT DIV.
END
FUNCTION ALL(JPT,IPTX)
COMMON /VV/LIMIT,V(1)
DIMENSION JPT(1)
K=IPTX-1
IF(K.GT.0)GO TO 2
1 K=JPT(-K)
IF(K)GO TO 1
C FOR 'ALL' WITH RR,RD,DF. FOLLOWS UP ON POINTERS TO POINTERS!
K=K-1
2 ALL=PARAM(V(K+3),K)
END
C THIS ROUTINE ALLOWS NAMES OF FROM 1 TO 5 LETTERS TO BE USED.
C NO EXTENSIONS CAN BE USED. INF RETURNS INFO REL LINE NUMS.
CC SUBROUTINE IFILE(I,N,INF)
CC EQUIVALENCE (NN,NAME),(NN2,NN(2))
CC COMMON /NN/NN(2)
CC DOUBLE PRECISION NAME
CC DATA NN(2)/'.'/
CC5 INF=0
CC NN(1)=N
CC OPEN(UNIT=I,FILE=NAME)
CC IF(NN2.NE.'.')GO TO 1
C JUMP IF COMING FROM OFILE CALL
CC READ(I,2)K,J
CC IF(K.NE.'00')GO TO 3
CC INF=-1
C INF = -1 = LINE NUMBERS.
CC6 OPEN(UNIT=I,FILE=NAME)
C REOPEN IF LINE NUMS OR NO "COMMENT"
CC GO TO 1
CC3 IF(K.NE.'CO')GO TO 6
CC IF(J.NE.'MMENT')GO TO 6
CC4 READ(I,2)K,J
C READS COMMENTS ON DIRECTORY PAGE.
CC IF(J.NE.';')GO TO 4
CC2 FORMAT(A2,A5)
CC1 NN2='.'
CC END
CC SUBROUTINE OFILE(I,N,IEXT)
CC COMMON /NN/NN1,NN2
CC NN2=IEXT
CC CALL IFILE(I,N,INF)
CC END